home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / src / error.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-10-20  |  2.9 KB  |  130 lines
  1. #include <varargs.h>
  2.  
  3. #include "scheme.h"
  4.  
  5. Object Arg_True;
  6.  
  7. static Object V_Error_Handler, V_Top_Level_Control_Point;
  8.  
  9. Init_Error () {
  10.     Arg_True = Cons (True, Null);
  11.     Global_GC_Link (Arg_True);
  12.     Define_Variable (&V_Error_Handler, "error-handler", Null);
  13.     Define_Variable (&V_Top_Level_Control_Point, "top-level-control-point",
  14.     Null);
  15. }
  16.  
  17. #ifdef lint
  18. /*VARARGS1*/
  19. Fatal_Error (foo) char *foo; { foo = foo; }
  20. #else
  21. Fatal_Error (va_alist) va_dcl {
  22.     va_list args;
  23.     char *fmt;
  24.  
  25.     va_start (args);
  26.     fmt = va_arg (args, char *);
  27.     (void)fflush (stdout);
  28.     fprintf (stderr, "\nFatal error: ");
  29.     vfprintf (stderr, fmt, args);
  30.     fprintf (stderr, ".\n");
  31.     va_end (args);
  32.     exit (1);
  33. }
  34. #endif
  35.  
  36. Panic (msg) char *msg; {
  37.     (void)fflush (stdout);
  38.     fprintf (stderr, "\nPanic: %s (dumping core).\n", msg);
  39.     abort ();
  40. }
  41.  
  42. Uncatchable_Error (errmsg) char *errmsg; {
  43.     Reset_IO (0);
  44.     Format (Curr_Output_Port, errmsg, strlen (errmsg), 0, (Object *)0);
  45.     (void)P_Newline (0, (Object *)0);
  46.     Reset ();
  47. }
  48.  
  49. #ifdef lint
  50. /*VARARGS1*/
  51. Primitive_Error (foo) char *foo; { foo = foo; }
  52. #else
  53. Primitive_Error (va_alist) va_dcl {
  54.     va_list args;
  55.     register char *p, *fmt;
  56.     register i, n;
  57.     Object msg, sym, argv[10];
  58.     GC_Node; GCNODE gcv;
  59.  
  60.     /* In case the error occurred after a Disable_Interrupts:
  61.      */
  62.     Enable_Interrupts;
  63.  
  64.     va_start (args);
  65.     fmt = va_arg (args, char *);
  66.     for (n = 0, p = fmt; *p; p++)
  67.     if (*p == '~' && p[1] != '~' && p[1] != '%') n++;
  68.     if (n > 10)
  69.     Panic ("Primitive_Error args");
  70.     for (i = 0; i < n; i++)
  71.     argv[i] = va_arg (args, Object);
  72.     sym = Null;
  73.     GC_Link (sym);
  74.     gcv.gclen = 1 + i; gcv.gcobj = argv; gcv.next = &gc1; GC_List = &gcv;
  75.     sym = Intern (Error_Tag);
  76.     msg = Make_String (fmt, p - fmt);
  77.     Err_Handler (sym, msg, i, argv);
  78.     /*NOTREACHED*/
  79. }
  80. #endif
  81.  
  82. Object P_Error (argc, argv) Object *argv; {
  83.     Check_Type (argv[1], T_String);
  84.     Err_Handler (argv[0], argv[1], argc-2, argv+2);
  85.     /*NOTREACHED*/
  86. }
  87.  
  88. Err_Handler (sym, fmt, argc, argv) Object sym, fmt, *argv; {
  89.     Object fun, args, a[1];
  90.     GC_Node3;
  91.  
  92.     Reset_IO (0);
  93.     args = Null;
  94.     GC_Link3 (args, sym, fmt);
  95.     args = P_List (argc, argv);
  96.     args = Cons (fmt, args);
  97.     args = Cons (sym, args);
  98.     fun = Var_Get (V_Error_Handler);
  99.     if (TYPE(fun) == T_Compound)
  100.     (void)Funcall (fun, args, 0);
  101.     a[0] = sym;
  102.     Format (Curr_Output_Port, "~s: ", 4, 1, a);
  103.     Format (Curr_Output_Port, STRING(fmt)->data, STRING(fmt)->size,
  104.     argc, argv);
  105.     (void)P_Newline (0, (Object *)0);
  106.     GC_Unlink;
  107.     Reset ();
  108.     /*NOTREACHED*/
  109. }
  110.  
  111. Reset () {
  112.     Object cp;
  113.  
  114.     cp = Var_Get (V_Top_Level_Control_Point);
  115.     if (TYPE(cp) == T_Control_Point)
  116.     (void)Funcall_Control_Point (cp, Arg_True, 0);
  117.     (void)fflush (stdout);
  118.     exit (1);
  119. }
  120.  
  121. Object P_Reset () {
  122.     Reset_IO (0);
  123.     Reset ();
  124.     /*NOTREACHED*/
  125. }
  126.  
  127. Range_Error (i) Object i; {
  128.     Primitive_Error ("argument out of range: ~s", i);
  129. }
  130.